home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / gnu / gawk / gawk213b.zoo / test / lisp / walk < prev    next >
Text File  |  1991-05-21  |  14KB  |  691 lines
  1. #!/bin/awk -f
  2. #
  3. # walk -- LISP in awk
  4. #
  5. # An interpreter for LISP, written in awk(1).
  6. # Copyright (c) 1988, 1990 Roger Rohrbach
  7.  
  8. BEGIN {
  9.  
  10.     # interpreter constants:
  11.  
  12.     stdin = "-";
  13.     true = 1;
  14.     false = 0;
  15.     constant = "#";            # flags literal atoms
  16.     alist = -10000;            # head of bound variable list
  17.  
  18.     # global variables:
  19.  
  20.     atom = -1;                # atoms are allocated down from -1
  21.     cell = 1;                # list cells are allocated up from 1
  22.  
  23.     environment = alist;        # pointer to current evaluation context;
  24.                     # saved in context[] before evaluating body
  25.                     # of lambda expression, restored afterwards
  26.  
  27.     # LISP constants:
  28.  
  29.     nil = intern["nil"] = atom--;   # intern[x] is the LISP atom named by x
  30.     name[nil] = "()";            # name[s] is the print name of atom s
  31.  
  32.     value[nil] = constant;        # if x < alist, value[x] is the local
  33.                     # binding of the atom `symbol[x]'; otherwise
  34.                     # it is the top-level binding of the atom x.
  35.  
  36.     t = intern["t"] = atom--;
  37.     name[t] = "t";
  38.     value[t] = constant;
  39.  
  40.     lambda = intern["lambda"] = atom--;
  41.     name[lambda] = "lambda";
  42.     value[lambda] = constant;
  43.  
  44.     # install the intrinsic functions:
  45.  
  46.     split("cons cdr car eq atom set eval error quote cond and or list", \
  47.      intrinsics);
  48.  
  49.     for (i in intrinsics)
  50.     {
  51.     id = intrinsics[i];
  52.     intern[id] = atom--;
  53.     name[intern[id]] = id;
  54.     value[intern[id]] = sprintf("@%d", i);
  55.     name[value[intern[id]]] = sprintf("<intrinsic #%d>", i);
  56.     }
  57.  
  58.     # these constants speed things up a bit
  59.  
  60.     CONS = value[intern["cons"]];
  61.     CDR = value[intern["cdr"]];
  62.     CAR = value[intern["car"]];
  63.     EQ = value[intern["eq"]];
  64.     ATOM = value[intern["atom"]];
  65.     SET = value[intern["set"]];
  66.     EVAL = value[intern["eval"]];
  67.     ERROR = value[intern["error"]];
  68.     QUOTE = value[intern["quote"]];
  69.     COND = value[intern["cond"]];
  70.     AND = value[intern["and"]];
  71.     OR = value[intern["or"]];
  72.     LIST = value[intern["list"]];
  73.  
  74.     # messages:
  75.  
  76.     TYPE_ERROR = "invalid argument to %s: %s\n";
  77.     REDEF_ERROR = "can't redefine intrinsic function %s\n";
  78.     UNDEF_ERROR = "undefined function: %s\n";
  79.  
  80.     HELLO = "walk (LISP in awk)\tCopyright (c) 1988, 1990 Roger Rohrbach\n";
  81.     GOODBYE = "%d atoms, %d list cells.\n";
  82.  
  83.  
  84.     # interpreter is ready
  85.  
  86.     if (FILENAME == stdin)
  87.     {
  88.     print HELLO;
  89.     printf("-> ");
  90.     }
  91. }
  92.  
  93. # interpreter loop:
  94.  
  95. {
  96.     pos = 0;        # current input character position
  97.     eol = length + 1;    # read past last char for endquote, below
  98.  
  99.     while (++pos <= eol)
  100.     {
  101.     #########
  102.     # read  #
  103.     #########
  104.  
  105.     if (endquote)
  106.     {
  107.         # close a quoted expr by inserting a right parenthesis
  108.         endquote = false;
  109.         c = ")";  
  110.         --pos;    # if at eol, c is null; push back on input
  111.     }
  112.     else
  113.         c = substr($0, pos, 1);
  114.  
  115.     if (c == " " || c == "\t")
  116.         continue;
  117.     else if (c == "" || c == ";")
  118.     {
  119.         # eol or comment
  120.         break;
  121.     }
  122.     else if (c == "'")
  123.     {
  124.         # expand 's to (quote s)
  125.         if (level > 0 && level != rp)
  126.         read[++rp] = CONS;
  127.         read[++rp] = CONS;
  128.         quotes[++qp] = ++level;
  129.         read[++rp] = intern["quote"];
  130.     }
  131.     else if (c == "\"")
  132.     {
  133.         string = true;
  134.     }
  135.     else if (c == "(")
  136.     {
  137.         # begin a list
  138.         read[++rp] = CONS;
  139.         ++level;
  140.     }
  141.     else if (c == ")")
  142.     {
  143.         if (level == 0)
  144.         {
  145.         printf("ignored extra right parenthesis\n");
  146.         continue;
  147.         }
  148.         else if (rp == level && read[rp] == CONS)
  149.         --rp;     # empty list read in
  150.  
  151.         # have just read a list
  152.         read[++rp] = nil;
  153.         --level;
  154.  
  155.         if (qp > 0 && quotes[qp] == level)
  156.         {
  157.         # finish quoting this list
  158.         --qp;
  159.         endquote = true;
  160.         }
  161.  
  162.         # actually construct the list
  163.         while (read[rp - 2] == CONS && read[rp - 1] != CONS)
  164.         {
  165.         cdr[cell] = read[rp];
  166.         car[cell] = read[--rp];
  167.         read[--rp] = cell++;
  168.         }
  169.     }
  170.     else if (c ~ /[0-9]/)
  171.     {
  172.         # read a number (integer)
  173.         n = c;
  174.         while ((c = substr($0, ++pos, 1)) ~ /[0-9]/)
  175.         n = n c;
  176.         --pos; 
  177.         if (level > 0 && level != rp)
  178.         read[++rp] = CONS;
  179.         if (!intern[n])
  180.         {
  181.         intern[n] = atom--;
  182.         name[intern[n]] = n;
  183.         value[intern[n]] = constant;
  184.         }
  185.         read[++rp] = intern[n];
  186.         if (qp > 0 && quotes[qp] == level)
  187.         {
  188.         --qp;
  189.         endquote = true;
  190.         }
  191.     }
  192.     else if (c ~ /[_A-Za-z]/ || string)
  193.     {
  194.         # read an identifier
  195.         id = c;
  196.         if (string)
  197.         {
  198.         while ((c = substr($0, ++pos, 1)) != "\"")
  199.             id = id c;
  200.         string = false;
  201.         }
  202.         else
  203.         {
  204.         while ((c = substr($0, ++pos, 1)) ~ /[-A-Za-z_0-9]/)
  205.             id = id c;
  206.         --pos;
  207.         }
  208.         if (level > 0 && level != rp)
  209.         read[++rp] = CONS;
  210.         if (!intern[id])
  211.         {
  212.         intern[id] = atom--;
  213.         name[intern[id]] = id;
  214.         value[intern[id]] = nil;
  215.         }
  216.         read[++rp] = intern[id];
  217.         if (qp > 0 && quotes[qp] == level)
  218.         {
  219.         --qp;
  220.         endquote = true;
  221.         }
  222.  
  223.     }
  224.     else if (c == "%")
  225.     {
  226.         # refer to objects by `address'
  227.         lispval = "";
  228.         while ((c = substr($0, ++pos, 1)) ~ /[-0-9]/)
  229.         lispval = lispval c;
  230.         if (!length(lispval))
  231.         lispval = nil;
  232.         --pos;
  233.         if (level > 0 && level != rp)
  234.         read[++rp] = CONS;
  235.         read[++rp] = lispval;
  236.         if (qp > 0 && quotes[qp] == level)
  237.         {
  238.         --qp;
  239.         endquote = true;
  240.         }
  241.     }
  242.     else
  243.         printf("illegal character: %s\n", c);
  244.  
  245.  
  246.     if (rp && level == 0)    # have read an s-expression
  247.     {
  248.         #########
  249.         # eval  #
  250.         #########
  251.  
  252.         eval[++ep] = read[rp--];
  253.  
  254.         while (ep > 0)
  255.         {
  256.         s = eval[ep];
  257.  
  258.         if (s < 0)
  259.         {
  260.             # atomic s-expression
  261.  
  262.             if (s == lambda && fp)
  263.             {
  264.             environment = context[fp--];    # restore environment
  265.             }
  266.             else if (value[s] == constant)
  267.             arg[++ap] = s;
  268.             else
  269.             {
  270.             # look up value of s in environment:
  271.             bound = false;
  272.             for (i = environment; i < alist; ++i)
  273.             {
  274.                 if (symbol[i] == s)
  275.                 {
  276.                 bound = true;
  277.                 break;
  278.                 }
  279.             }
  280.             if (bound)
  281.                 arg[++ap] = value[i];
  282.             else    # use value cell
  283.                 arg[++ap] = value[s];
  284.             }
  285.             --ep;
  286.         }
  287.         else if (index(s, "@"))
  288.         {
  289.             # intrinsic function application:
  290.  
  291.             if (s == CONS)
  292.             {
  293.             car[cell] = arg[ap];
  294.             cdr[cell] = arg[--ap];
  295.             if (cdr[cell] < 0 && cdr[cell] != nil)
  296.             {
  297.                 printf(TYPE_ERROR, "cons", name[cdr[cell]]);
  298.                 arg[ap = ep = 1] = nil; # stop evaluation
  299.             }
  300.             else
  301.                 arg[ap] = cell++;
  302.             }
  303.             else if (s == CDR)
  304.             {
  305.             if (arg[ap] < 0)
  306.             {
  307.                 printf(TYPE_ERROR, "cdr", name[arg[ap]]);
  308.                 arg[ap = ep = 1] = nil;
  309.             }
  310.             else
  311.                 arg[ap] = cdr[arg[ap]];
  312.             }
  313.             else if (s == CAR)
  314.             {
  315.             if (arg[ap] < 0)
  316.             {
  317.                 printf(TYPE_ERROR, "car", name[arg[ap]]);
  318.                 arg[ap = ep = 1] = nil;
  319.             }
  320.             else
  321.                 arg[ap] = car[arg[ap]];
  322.             }
  323.             else if (s == EQ)
  324.             {
  325.             arg1 = arg[ap];
  326.             if (arg[--ap] == arg1)
  327.                 arg[ap] = t;
  328.             else
  329.                 arg[ap] = nil;
  330.             }
  331.             else if (s == ATOM)
  332.             {
  333.             if (arg[ap] < 0)
  334.                 arg[ap] = t;
  335.             else
  336.                 arg[ap] = nil;
  337.             }
  338.             else if (s == SET)
  339.             {
  340.             if ((arg1 = arg[ap]) > 0)
  341.             {
  342.                 printf(TYPE_ERROR, "set", "must be atomic");
  343.                 arg[ap = ep = 1] = nil;
  344.             }
  345.             else if (value[arg1] == constant)
  346.             {
  347.                 printf(TYPE_ERROR, "set", name[arg1]);
  348.                 arg[ap = ep = 1] = nil;
  349.             }
  350.             else if (index(value[arg1], "@"))
  351.             {
  352.                 printf(REDEF_ERROR, name[arg1]);
  353.                 arg[ap = ep = 1] = nil;
  354.             }
  355.             else
  356.             {
  357.                 bound = false;
  358.                 for (i = environment; i < alist; ++i)
  359.                 {
  360.                 if (symbol[i] == arg1)
  361.                 {
  362.                     bound = true;
  363.                     break;
  364.                 }
  365.                 }
  366.                 arg2 = arg[--ap];
  367.  
  368.                 if (bound)    # replace binding
  369.                 arg[ap] = value[i] = arg2;
  370.                 else    # set value
  371.                 arg[ap] = value[arg1] = arg2;
  372.             }
  373.             }
  374.             else if (s == EVAL)
  375.             {
  376.             eval[ep++] = arg[ap--];
  377.             }
  378.             else if (s == ERROR)
  379.             {
  380.             if (arg[ap] > 0)
  381.                 printf(TYPE_ERROR, "error", "must be atomic");
  382.             else
  383.                 printf("%s\n", n